perm filename MUS2.F4[P11,LCS] blob
sn#592327 filedate 1981-06-07 generic text, type T, neo UTF8
00100 C***** MUS2.F4 *******
00200 C***** SCANR, LNEND, BARS, SCAN2, SCAN3, SCAN4
00300 C ***** MSS SCANNER ******* SCN/FOR *********
00400 SUBROUTINE SCANR
00500 DIMENSION IQ(10),LRUD(4)
00600 COMMON /ALF/INP(72),ML
00700 COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
00800 1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
00900 CC 1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
00920 COMMON/SCX/ICOM,MINUS,IDOT,IEQ,LPRN,IRPRN,IPLUS,ISTAR,ICOLON,
00940 1 ISEMI,IDBQT,IBLA,IDOL,IPRCNT,IANPR,IAT,INUM,LESS,IGT,IAPOS,
00960 1 IQUES,IEXCLA,LBRK,RBRK,UPAR,DNAR,DBLAR,KSLA,XX,ZZ,
00980 1 JX,RA,JZ,IRHY,RB,KA,KB,IZ
01000 CC 1 /JCHAR/IXX,ISEMI,JBLA,IG
01100 COMMON /SC/J,LSC,MK
01200 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
01300 1 ,VX(50),IAMP,K,RRN,M,MODE,JBLA
01400 EQUIVALENCE (IQ(1),VX(41)),(VX1,VX(1)),(VX2,VX(2)),(LDN,LRUD(4))
01410 1,(VX4,VX(4))
01500 CC 1,(KSLA,JALPHA(28)),(ISTAR,JALPHA(8)),(ICOM,JALPHA(1)),
01600 CC 1(MINUS,JALPHA(2)),(IPLUS,JALPHA(7)),(IDOT,JALPHA(3))
01700 DATA LRUD/'L','R','U','D'/
01800 C FOR LEFT, RIGHT, UP, DOWN, EDIT
01900 NNUM=-1
02000 ISKP=0
02100 JJ=0
02200 XMINUS=1.
02300 C LEAVES BLANK WHEN REST.
02400 999 IDEC=99
02500 M=0
02600 2799 N=INP(ML)
02700 899 ML=ML+1
02800 781 IF(N.EQ.KSLA)N=ISEMI
02900 C FOR MOTIVIC TRANFORMATIONS
03000 IF(N.EQ.ISTAR)GO TO 751
03100 IF(N.EQ.ISEMI)GO TO 751
03200 C '*' AND '/' ADDED ABOVE 4/18/73
03300 IF(N.NE.LXX)GO TO 22
03400 IF(JN)GO TO 22
03500 IF(ISKP.EQ.0)GO TO 210
03600 ML=ML-1
03700 GO TO 202
03800 22 IF(N.EQ.IBLA)GO TO 4702
03900 IF(N.NE.ICOM)GO TO 510
04000 4702 IF(ISKP)202,2799,2799
04100 4 IF(K.LT.19)GO TO 2799
04200 IF(K.GT.20)GO TO 2799
04300 CALL SCAN2(QZ)
04400 C SCAN2 IS FOR METER, STEM DIR., STAFF UP-DN
04500 IF(QZ)2799,512,4002
04600 512 ML=ML+1
04700 IF(INP(ML).EQ.ISEMI)RETURN
04800 GO TO 512
04900
05000 510 IF(JN.GE.0)GO TO 173
05100 C SKIP(JN=+1) IF NOT COMING FROM 'EDIT'
05200 JN=1
05300 DO 702 K=1,4
05400 702 IF(N.EQ.LRUD(K))GO TO 703
05500 C FINDS L, R, U, D
05600 IF(N.GT.IBLA)GO TO 899
05700 C GO TO 703 IF REALLY A LETTER, ELSE MOVE UP POINTER
05800 703 JJ=JJ+1
05900 C YOU CAN TYPE THE FULL WORD
06000 IF(K.NE.4)GO TO 77
06100 IF(INP(ML).EQ.LEE)K=99
06200 C 'DE'=DELETE
06300 77 IF(N.EQ.LEE)K=55
06400 C 'E'= EDIT
06500 IF(N.EQ.LCC)K=2222
06600 IF(N.EQ.LXX)K=222
06700 C 'C'=COPY, 'X'=EXIT FROM EDIT MODE
06800 VX(JJ)=K
06900 704 IF(INP(ML).EQ.IBLA)GO TO 2799
07000 IF(INP(ML).GT.0)GO TO 2799
07100 C IF NEXT CHAR. IS A LETTER(NEG.), SKIP IT.
07200 C PUT COMMA ERASER IN SCX.
07300 ML=ML+1
07400 C SO IT WILL SKIP 'D' AND 'EL' IN 'EDIT' AND 'DEL'
07500 GO TO 704
07600 173 K=NALF(N)
07700 IF(N.GT.0)GO TO 1410
07800 IF(K.EQ.18)GO TO 73
07900 C JUMP IF A REST OR OTHER R'S
08000 IF(MODE.EQ.2)GO TO 144
08100 C ;YOU CAN TYPE 'S', ETC., FOR SIXTEENTH ETC., RHYTHM.
08200 C ; JUMP IF NOT A LETTER
08300
08400 C notes = 1xyz.0 x=accidental, yz=note num., negative=chord note
08500 C rest = 2xyz.0 z=0=ordinary, =1=invis., =2=whole, =3=repeat bar
08600 C =4=down, =5=up, -2xyz=num. of meas. rest
08700 C clefs = 3xyz.0 z=0=treble, =1=bass, =2=alto, =3=tenor, neg.=invis.
08800 C use TRE,BAS,ALT,TEN for clefs with no change to note levels.(4,5,6,7)
08900 C bars = 4xyz.0 z=num. of staves up, neg.=dbl.bar
09000 C ksig = 17xyz.0 z=num. of accis., pos.=#, neg.=b, x=1 for naturals.
09100 C meter = 18xyz.n xy=top num, zn=bottom num (DONE IN SCMSS)
09200 C stem = 5xyz.0 YZ=10=stem up, =20=stem down
09300 C staff = 5xyz.0 z=0=return to norm., =1=lower stf., =2=upper stf.
09400
09500 IF(K.LT.8)GO TO 15
09600 C JUMP IF A POSSIBLE NOTE
09700 IF(K.NE.11)GO TO 16
09800 C JUMP IF NOT A KSIG
09900 CALL SCAN4
10000 RETURN
10100
10200 C NOW LOOK FOR 'I'
10300 16 IF(K.NE.9)GO TO 2
10400 VX(1)=22.
10500 C FOR EDIT I21 ETC.
10600 GO TO 2799
10700 C NOW 'M'
10800 2 IF(K.NE.13)GO TO 3
10900 CALL BARS
11000 C ***** BARS =4000 ******
11100 GO TO 512
11200
11300 3 IF(K.GT.16)GO TO 4
11400 C JUMP IF NOT FOR 'PROXIMITY' MODE
11500 NSWCH=K-15
11600 GO TO 2799
11700 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
11800 CXX4 IF(SCAN2(QZ))2799,4002,512
11900
12000 15 N=INP(ML)
12100 IF(K.NE.2)GO TO 5
12200 C CAIN K,2 ;IF(1ST LETR.NE.'B')GO TO S5
12300 IF(N.NE.LAA)GO TO 5
12400 C JUMP IF NOT BASS CLEF
12500 QZ=3001.
12600 C MOVE 02,[3001.0] ;BASS CLEF=3001
12700 4002 N=INP(ML+1)
12800 C GET 3RD CHAR.
12900 IF(N.EQ.IBLA.OR.N.EQ.KSLA.OR.N.EQ.ISEMI)GO TO 5002
13000 C IF 3RD CHAR IS SIGNIFICANT THEN SPECIAL CLEF
13100 C 4,5,6,7 = 0,1,2,3 BUT NO INFLUENCE ON NOTE LEVEL
13200 QZ=QZ+4.
13300 ML=ML+1
13400 5002 VX(1)=QZ
13500 51 IF(XMINUS.LT.0)VX(1)=-VX(1)
13600 C TYPE '-BA' FOR INVISIBLE BASS CLEF, ETC.
13700 GO TO 512
13800 5 IF(N.NE.LEL)GO TO 6
13900 C JUMP IF NOT ALTO CLEF
14000 QZ=3002.0
14100 GO TO 4002
14200 6 CALL SCAN3(NSWCH)
14250 C FOR NOTE NAMES
14300
14400 4410 IF(INP(ML).EQ.ISEMI)RETURN
14500 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
14600 GO TO 310
14700
14800 210 JJ=JJ+1
14900 IF(JJ.EQ.1)GO TO 3310
15000 XMINUS=1.
15100 VX(JJ)=0
15200 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
15300 GO TO 310
15400 C JUMP IF A LETTER
15500 1410 IF(N.NE.MINUS)GO TO 544
15600 XMINUS=-1.
15700 IF(JJ.EQ.0)GO TO 2799
15800 C -- FOR '-BA' ETC.
15900 IF(MODE.EQ.1)GO TO 644
16000 C [FOR AUTO OCT. SYS.]
16100 GO TO 2799
16200 544 IF(MODE.NE.1)GO TO 14
16300 IF(N.NE.IPLUS)GO TO 14
16400 644 VX4=7.
16500 K=NALF(INP(ML))
16600 IF(K.GT.9.OR.K.LE.0)GO TO 744
16700 VX4=K
16800 ML=ML+1
16900 744 IF(N.NE.IPLUS)VX4=-VX4
17000 GO TO 2799
17100 C DEFAULT IS OCTAVE. (+ OR - 7)
17200 144 CALL RHYLTR
17300 C FOR INPUT OF RHYTHM WITH LETTERS - Q,E,S,W,G,H,D,T
17400 GO TO 1310
17500 14 ISKP=-1
17600 IF(N.NE.IDOT)GO TO 79
17700 IDEC=M
17800 CXX DECI=M
17900 GO TO 75
18000 79 M=M+1
18100 IQ(M)=NALF(N)
18200 75 IF(N.EQ.ISEMI)GO TO 751
18300 IF(INP(ML).NE.1)GO TO 2799
18400 751 IF(ISKP.EQ.0)RETURN
18500 202 A=0
18600 C=1.0
18700 IF(M.LE.0)M=1
18800 DO 1 K=1,M
18900 A=A*10.+IQ(K)
19000 1 IF(K.GT.IDEC)C=C*0.1
19100 JJ=JJ+1
19200 VX(JJ)=A*C*XMINUS
19300 JN=-JN
19400 C SETS IT TO -1 FOR L,R,U,D EDIT ROUTINE
19500 IF(MODE.NE.2)XMINUS=1.
19600 C************: MODE #?
19700 C ONLY ONE '-' NEEDED FOR RHY.COMPOSITE
19800 1310 IF(INP(ML).NE.1)GO TO 310
19900 VX(JJ)=VX(JJ)+1000.
20000 C 1000 IS ADDED FOR EACH DOT. NO MORE COMPOSITES!
20100 ML=ML+1
20200 GO TO 1310
20300 206 ML=ML+2
20400 3310 VX(1)=-99.
20500 310 ISKP=0
20600 IF(N.NE.ISEMI)GO TO 999
20700 RETURN
20800
20900 73 JJ=JJ+1
21000 K=INP(ML)
21100 IF(K.EQ.LEE)GO TO 206
21200 C NEXT IS FOR A REST/R/ OR /RI/ FOR INVIS. REST
21300 CALL RESTIN
21400 GO TO 4410
21500 END
21600
21700 SUBROUTINE RHYLTR
21800 COMMON /ALF/INP(72),ML
21900 COMMON /SC/J,LSC,MK
22000 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
22100 1 ,VX1,VX(49),IAMP,K,RRN,M,MODE,IBLA
22200
22300 C FOR INPUT OF RHYTHM WITH LETTERS - Q=17,E=5,S=19,W=23,G=7,H=8,D=4,T=20
22400 ITRIP=0
22500 444 IF(K.NE.17)GO TO 7444
22600 VX1=4.
22700 GO TO 2444
22800 7444 IF(K.NE.5)GO TO 1444
22900 VX1=8.
23000 GO TO 2444
23100 1444 IF(K.NE.19)GO TO 8444
23200 VX1=16.
23300 GO TO 2444
23400 8444 IF(K.NE.23)GO TO 5444
23500 VX1=1.
23600 GO TO 2444
23700 5444 IF(K.NE.7)GO TO 6444
23800 VX1=88.
23900 GO TO 2444
24000 6444 IF(K.NE.8)GO TO 3444
24100 VX1=2.
24200 GO TO 2444
24300 3444 IF(K.NE.4)GO TO 4444
24400 244 VX1=.5
24500 GO TO 2444
24600 4444 IF(K.NE.20)GO TO 244
24700 C WRONG LETTER WILL DEFAULT TO 'D' DOUBLE WHOLE NOTE
24800 VX1=12.
24900 N=INP(ML)
25000 IF(N.EQ.IBLA)GO TO 2444
25100 IF(N.EQ.JSEMI)GO TO 2444
25200 IF(N.EQ.1)GO TO 2444
25300 C (DOT WAS CHANGED TO 1)
25400 IF(N.EQ.JXX)GO TO 2444
25500 ITRIP=-1
25600 ML=ML+1
25700 K=NALF(N)
25800 N=INP(ML)
25900 GO TO 444
26000 C TS=24TH, TQ=6, TH=3.
26100 C FOR S,E,Q,H,W,D,T RHYTH. 'T'(K=20) =TRIPLET D=DBL WHL NOTE
26200 2444 IF(ITRIP.LT.0)VX1=VX1*1.5
26300 JJ=JJ+1
26400 END
26500
26600 SUBROUTINE RESTIN
26700 C NEXT IS FOR A REST/R/ OR /RI/ FOR INVIS. REST
26800 COMMON /ALF/INP(72),ML
26900 COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
27000 1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
27100 COMMON /SC/J,LSC,MK
27200 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
27300 1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
27400
27500 IF(K.EQ.LDD)GO TO 1073
27600 C /RD/ OR /RU/ = REST 6 DOWN OR 6 UP.
27700 IF(K.EQ.LUU)GO TO 1173
27800 IF(K.EQ.LII)GO TO 573
27900 IF(K.EQ.LWW)GO TO 273
28000 C /RW/ MAKES WHOLE REST REGARDLESS OF TIME VALUE GIVEN.
28100 IF(K.EQ.LRR)GO TO 1273
28200 C /RR/ MAKES REPEAT BAR SIGN (REST=-4)
28300 C ; *** ADD NUMBERS LATER *****; 22932
28400 K=NALF(K)
28500 IF(K.LT.0)GO TO 673
28600 IF(K.GE.10)GO TO 673
28700 973 KV=NALF(INP(ML+1))
28800 C FOR 3-DIG. NUMBS. CAN TAKE NUM UP TO 999 FOR RESTS.
28900 IF(KV.LT.0)GO TO 873
29000 IF(KV.GE.10)GO TO 873
29100 ML=ML+1
29200 K=K*10+KV
29300 C 15 IS K FOR NOW AND K IS IV
29400 GO TO 973
29500 873 QQ=-2000.-QQ
29600 C RW =2002
29700 GO TO 473
29800 673 QQ=2000.
29900 C ORDINARY REST
30000 GO TO 373
30100 573 QQ=2001.
30200 C INVISIBLE REST
30300 GO TO 473
30400 273 QQ=2002.
30500 C WHOLE REST (NO MATTER WHAT RHYTH.)
30600 473 ML=ML+1
30700 373 VX(JJ)=QQ
30800 RETURN
30900 1073 QQ=2004.
31000 C RD = REST DOWN 2004
31100 GO TO 473
31200 1173 QQ=2005.
31300 C RU = REST UP 2005
31400 GO TO 473
31500 1273 QQ=2003.
31600 C RR = BAR REPEAT SIGN
31700 GO TO 473
31800 END
31900
32000
32100 C***** LNEND, BARS, SCAN2, SCAN3, SCAN4
32200
32300 SUBROUTINE LNEND
32400 COMMON/ALF/JNP(72),ML/MKX/LSL
32500 1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
32700 EQUIVALENCE (LST,JALPHA(8)),(LCM,JALPHA(10))
32800 K=1
32900 C IF BAD INPUT PUT ISEMI INTO ALF(4) [JNP1] AT END
33000 C LST * SCX+7
33100 C LCM ;
33200 C LSL /
33300 K3=1
33400 K5=72
33500 2901 IF(LSL.NE.JNP(K3))GO TO 2903
33600 K=K3
33700 GO TO 2902
33800 2903 IF(LCM.NE.JNP(K3))GO TO 2902
33900 JNP(K3)=LST
34000 RETURN
34100 2902 K3=K3+1
34200 IF(K3.LE.K5)GO TO 2901
34300 JNP(K)=LCM
34400 C GET LOC. OF LAST /
34500 END
34600
34700 SUBROUTINE BARS
34800 COMMON /ALF/INP(72),ML /SC/J,LSC,MK
34900 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
35000 1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
35100 COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
35200 1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
35300 C ***** BARS =4000 ****** ; THE 1 IS FOR BAR ONE STAFF ONLY.
35400 QZ=4001.
35500 2002 JN=INP(ML)
35600 IF(JN.EQ.LDD)GO TO 3002
35700 IF(JN.NE.LMM)GO TO 23
35800 VX(1)=VX(1)+1.
35900 ML=ML+1
36000 GO TO 2002
36100 C GO BACK AND LOOK FOR MORE M'S ML=ML+1
36200 3002 ML=ML+1
36300 C FOUND 'MDN' -- FOR DOUBLE BARS
36400 JN=0
36500 QZ=-QZ
36600 C DBL BARS ARE NEG.
36700 23 VX(1)=QZ
36800 K=NALF(INP(ML))
36900 IF(K.LE.0)RETURN
37000 IF(K.GT.9)RETURN
37100 C NO MORE THAN 8 STAVES UP ALLOWED.
37200 K=K-1
37300 C BECAUSE ORIG. NUM WAS 4001, NOT 4000
37400 IF(JN.EQ.0)K=-K
37500 C NEG. IF DBL BAR
37600 VX(1)=VX(1)+K
37700 C 'M2'= A BAR LINE UP 2 STAVES. ETC.
37800 END
37900
38000 SUBROUTINE SCAN2(QZ)
38100 C FOR METER(Tm n), STEM DIR.(SU,SD), STAFF UP-DN
38200 COMMON /ALF/INP(72),ML /SC/J,LSC,MK
38300 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
38400 1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
38500 COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
38600 1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
38700 4 IF(K.NE.20)GO TO 21
38800 QZ=-1
38900 C TRY AGAIN IF NOT A 'T'
39000 IF(INP(ML).GT.0)RETURN
39100 C T12,8/ ETC. MAKES A METR, OR TIM SIG. POS NUMS AREN'T LETRS!
39200 C ***** CLEFS = 3000 ***** CODE 3.
39300 QZ=3000.
39400 IF(INP(ML).EQ.LEE)QZ=QZ+3.
39500 C TENOR CLEF =3003, TREBLE=3000
39600 RETURN
39700 C NOT AN 'S'(STEM OR STAFF), UNKNOWN ITEM, SKIP IT.
39800 21 KI=INP(ML)
39900 C SU UP=5010
40000 QQ=0
40100 IF(KI.EQ.LUU)QQ=10.
40200 IF(KI.EQ.LDD)QQ=20.
40300 C DOWN = 5020
40400 IF(KI.EQ.'+')QQ=2.
40500 C S+=5002
40600 IF(KI.EQ.'-')QQ=1.
40700 C S-=5001
40800 C S0=5000
40900 C THESE ARE FOR S+, S-, S0; PUT NOTE ON OTHER STF.
41000 VX(1)=5000.+QQ
41100 QZ=0
41200 END
41300
41400 SUBROUTINE SCAN3(NSWCH)
41500 C FOR NOTE NAMES.
41600 COMMON /ALF/INP(72),ML /SC/J,LSC,MK
41700 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
41800 1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
41900 COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
42000 1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
42100 6 K=K-2
42200 C -2 BECAUSE MUSICAL ALPHABET STARTS WITH C
42300 IF(K.LE.0)K=K+7
42400 NNUM=K
42500 KQ=1000
42600 K=1
42700 IF(NNUM.GT.3)K=K+1
42800 C FOUND A NOTE
42900 IF(N.EQ.JXX)GO TO 5410
43000 C FOR GX3/ ETC.
43100
43200 IF(N.NE.INP(ML-1))GO TO 66
43300 C NO DOUBLE-LETTER ACCID. (FLAT)
43400 IF(N.NE.INP(ML+1))GO TO 88
43500 C NO TRIPLE-LETTER ACCID. (SHARP)
43600 ML=ML+1
43700 IF(N.NE.INP(ML+1))GO TO 8
43800 C NO TRIPLE-LETTER ACCID. (NATURAL)
43900 ML=ML+1
44000 KQ=1300
44100 C TYPE AA FOR AF, AAA = AS, AAAA = AN
44200 GO TO 610
44300
44400 66 K=NALF(N)
44500 IF(N.GT.0)GO TO 7
44600 C JUMP IF NOT A LETTER
44700 KQ=1300
44800 C ; ***** NOTES ***** =1000 2ND DIG=ACCI.
44900 IF(K.EQ.22)GO TO 610
45000 C *** CAN USE 'V' FOR NATURAL(EASIER TO HIT!!)
45100 IF(K.EQ.14)GO TO 610
45200 C JUMP IF NATURAL
45300 IF(K.EQ.19)GO TO 8
45400 C -- S --
45500 88 KQ=1100
45600 C IT'S A FLAT
45700 GO TO 610
45800 8 KQ=1200
45900 C SHARP =1200
46000 610 ML=ML+1
46100 NK=INP(ML)
46200 K=NALF(NK)
46300 IF(NK.GE.0)GO TO 7
46400 C IF CHAR. ISN'T A LETTER, GO TO S7
46500 C (LETTERS ARE NEG., NUMBS ARE POS.)
46600 IF(K.NE.19)GO TO 777
46700 C IF(K.EQ.19) THEN IT'S SS
46800 C FOR DBL FLAT, DBL SHARP
46900 KQ=1500
47000 C DBL FLAT
47100 GO TO 610
47200 777 IF(K.NE.6)GO TO 7
47300 C IS IT 'FF'?
47400 KQ=1400
47500 C FF=1400, SS=1500
47600 GO TO 610
47700 C GO BACK FOR ANOTHER CHAR.
47800 7 IF(K.EQ.11)GO TO 5410
47900 C IS IT 'K'?
48000 IF(K.LT.0)GO TO 5410
48100 C IF SEMICOLON OR BLANK
48200 IF(K.NE.24)GO TO 24
48300 C IS IT 'X'?
48400 GO TO 5410
48500 24 JSCA=K
48600 C SAVE OCT. NUM
48700 ML=ML+1
48800 GO TO 2410
48900 5410 IF(NSWCH.EQ.0)GO TO 2410
49000 JJ=NOLD-NNUM
49100 IF(JJ.GE.4)JSCA=JSCA+1
49200 IF(JJ.LE.-4)JSCA=JSCA-1
49300 C WILL JUMP TO NEAREST NOTE (DIATONIC-'75)
49400 2410 JJ=1
49500 VX(2)=0
49600 QQ=JSCA*7+NNUM+KQ
49700 VX(1)=QQ*DBST
49800 C DOUBLE STOPS ARE NEG. NnUMBERS
49900 NOLD=NNUM
50000 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
50100 END
50200
50300 SUBROUTINE SCAN4
50400 C FOR KEY SIGS.
50500 COMMON /ALF/INP(72),ML /SC/J,LSC,MK
50600 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,JXX,JSEMI,QQ
50700 1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
50800 COMMON/A2Z/LAA,LBB,LCC,LDD,LEE,LFF,LGG,LHH,LII,LJJ,LKK,LEL,LMM
50900 1 ,LNN,LOH,LPP,LQQ,LRR,LSS,LTT,LUU,LVV,LWW,LXX,LYY,LZZ
51000 QQ=17000.
51100 CC**** NUM FOR KEY SIGS ***
51200 18 N=INP(ML)
51300 ML=ML+1
51400 IF(N.EQ.IBLA)GO TO 18
51500 IF(N.NE.LNN)GO TO 200
51600 C IS IT AN N? K3FN/ OR K2SN/ MAKES NATURALS
51700 C IF NEXT CHAR='N' A 'NATURALS' KEY SIG.
51800 QZ=100.
51900 IF(QQ.LE.0)QZ=-QZ
52000 QQ=QQ+QZ
52100 GO TO 18
52200 200 IF(N.EQ.LSS)GO TO 18
52300 IF(N.EQ.'+')GO TO 18
52400 IF(N.EQ.JSEMI)GO TO 20
52500 IF(N.EQ.'-')N=LFF
52600 IF(N.NE.LFF)GO TO 19
52700 QQ=-QQ
52800 C NEG. FOR FLATS
52900 GO TO 18
53000 19 A=NALF(N)
53100 GO TO 18
53200 C GO BACK AND LOOK AGAIN
53300 20 IF(QQ.LT.0)A=-A
53400 VX(1)=QQ+A
53500 C KSIG
53600 END